home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Applications / TCPExample / PNL Libraries / TCPUtils.p < prev   
Text File  |  1997-04-01  |  13KB  |  499 lines
  1. unit TCPUtils;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Types, TCPTypes;
  7.         
  8.     var
  9.         mactcp_driver_refnum:integer;
  10.  
  11.     type
  12.         TCPXControlBlock = record
  13.                 completion: ProcPtr;
  14.                 pb: TCPControlBlock;
  15.             end;
  16.         TCPXControlBlockPtr = ^TCPXControlBlock;
  17.  
  18.         TCPStateType = (T_WaitingForOpen, T_Dead, T_Bored, T_Opening, T_Established,
  19.             T_Closing, T_PleaseClose, T_Unknown);
  20. { T_Bored means listening or closed }
  21.  
  22.     type
  23.         DNRCompletionProcPtr = ProcPtr;
  24. { procedure DNRCompletionProc(drp:DNRRecordPtr); }
  25.         DNRRecord = record
  26. { Generally you only need to look at the first three of these }
  27.                 ioResult: OSErr;
  28.                 name: Str255;
  29.                 addr: longint;
  30.                 completion: DNRCompletionProcPtr;
  31.                 case integer of
  32.                     1: (
  33.                             hi: hostInfo;
  34.                     );
  35.                     2: (
  36.                             cacherec: cacheEntryRecord;
  37.                     );
  38.             end;
  39.         DNRRecordPtr = ^DNRRecord;
  40.     
  41.     type
  42.         PingRecordPtr = ^PingRecord;
  43.         PingCompletionProc = procedure (cbp: IPControlBlockPtr; irp:PingRecordPtr);
  44.         PingRecord = record
  45.                 completion: PingCompletionProc;
  46.             end;
  47.     
  48.     var
  49.         ping_sent_out, ping_got_back: longint;
  50.         
  51.     procedure StartupTCPUtils;
  52.     
  53.     function MTTCPCreate(var stream:StreamPtr; buffer:Ptr; buffer_size:longint):OSErr;
  54.     function MTTCPRelease(var stream:StreamPtr):OSErr;
  55.     function MTTCPActiveOpen(var cb:TCPControlBlock; stream:StreamPtr; local_port: ipPort; remote_ip: longint; remote_port: ipPort):OSErr;
  56.     function MTTCPPassiveOpen(var cb:TCPControlBlock; stream:StreamPtr; var local_port: ipPort):OSErr;
  57.     function MTTCPClose(var cb:TCPControlBlock; stream:StreamPtr):OSErr;
  58.     function MTTCPAbort(stream:StreamPtr):OSErr;
  59.     function MTTCPState(stream:StreamPtr):TCPStateType;
  60.     function MTMapState( state: longint): TCPStateType;
  61.  
  62.     function MTUDPCreate(var stream:StreamPtr; var localport: ipPort; outstanding_count_ptr: LongIntPtr; buffer:Ptr; buffer_size:longint):OSErr;
  63.     function MTUDPRelease (stream:StreamPtr): OSErr;
  64.     function MTUDPRead (stream:StreamPtr; outstanding_count_ptr: LongIntPtr; var remoteip: longint; var remoteport: ipPort;
  65.                                     var datap: Ptr; var datalen: integer): OSErr;
  66.     function MTUDPReturnBuffer (stream:StreamPtr; datap: Ptr): OSErr;
  67.     function MTUDPWrite (stream:StreamPtr; remoteip: longint; remoteport: ipPort;
  68.                                     datap: Ptr; datalen: integer; checksum: boolean): OSErr;
  69.  
  70.     function MTIPSendPing (remotehost: ipAddr; timeout: integer; datap: Ptr; datalen: integer; complete: PingCompletionProc; irp: PingRecordPtr): OSErr;
  71.  
  72.     procedure SanitizeHostName (var s: Str255);
  73.  
  74.     procedure DNRNameToAddr (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
  75.     procedure DNRNameToHInfo (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
  76.     procedure DNRAddrToName (addr: longint; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
  77.  
  78.     procedure MTZeroTCPCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);
  79.     procedure MTZeroUDPCB (var cb: UDPControlBlock; stream: StreamPtr; call: integer);
  80.  
  81. implementation
  82.     
  83.     uses
  84.         Devices, Memory, Events, 
  85.         MyCStrings, MyCallProc, DNR, MyMemory, MyStartup, MyAssertions, PreserveA5;
  86.         
  87. {$ifc do_debug}
  88.     var
  89.         startup_check: integer;
  90. {$endc}
  91.  
  92.     var
  93.         gDNRNameToAddrCompletionProc:UniversalProcPtr;
  94.         gDNRAddrToNameCompletionProc:UniversalProcPtr;
  95.         gUDPNotifyProc:UniversalProcPtr;
  96.         gIPPingCompletionProc:UniversalProcPtr;
  97.         
  98.     procedure MTZeroTCPCB (var cb: TCPControlBlock; stream: StreamPtr; call: integer);
  99.     begin
  100.         MZero(@cb, SizeOf(cb));
  101.         cb.tcpStream := stream;
  102.         cb.ioCRefNum := mactcp_driver_refnum;
  103.         cb.csCode := call;
  104.     end;
  105.  
  106.     procedure MTZeroUDPCB (var cb: UDPControlBlock; stream: StreamPtr; call: integer);
  107.     begin
  108.         MZero(@cb, SizeOf(cb));
  109.         cb.udpStream := stream;
  110.         cb.ioCRefNum := mactcp_driver_refnum;
  111.         cb.csCode := call;
  112.     end;
  113.  
  114.     function MTTCPCreate(var stream:StreamPtr; buffer:Ptr; buffer_size:longint):OSErr;
  115.         var
  116.             err:OSErr;
  117.             cb:TCPControlBlock;
  118.     begin
  119.         AssertDidStartup( startup_check );
  120.         MTZeroTCPCB(cb, nil, TCPcsCreate);
  121.         cb.create.rcvBuff := buffer;
  122.         cb.create.rcvBuffLen := buffer_size;
  123.         err := PBControlSync(@cb);
  124.         if err = noErr then begin
  125.             stream := cb.tcpStream;
  126.         end else begin
  127.             stream := nil;
  128.         end;
  129.         MTTCPCreate := err;
  130.     end;
  131.     
  132.     function MTTCPRelease(var stream:StreamPtr):OSErr;
  133.         var
  134.             cb:TCPControlBlock;
  135.     begin
  136.         MTZeroTCPCB(cb, stream, TCPcsRelease);
  137.         MTTCPRelease := PBControlSync(@cb);
  138.         stream := nil;
  139.     end;
  140.  
  141.     function MTTCPActiveOpen(var cb:TCPControlBlock; stream:StreamPtr; local_port: ipPort; remote_ip: longint; remote_port: ipPort):OSErr;
  142.     begin
  143.         MTZeroTCPCB(cb, stream, TCPcsActiveOpen);
  144.         cb.open.localport := local_port;
  145.         cb.open.remotehost := remote_ip;
  146.         cb.open.remoteport := remote_port;
  147.         cb.open.ulpTimeoutAction := -1;
  148.         MTTCPActiveOpen := PBControlAsync(@cb);
  149.     end;
  150.  
  151.     function MTTCPPassiveOpen(var cb:TCPControlBlock; stream:StreamPtr; var local_port: ipPort):OSErr;
  152.         var
  153.             err:OSErr;
  154.     begin
  155.         MTZeroTCPCB(cb, stream, TCPcsPassiveOpen);
  156.         cb.open.localport := local_port;
  157.         cb.open.ulpTimeoutAction := -1;
  158.         err := PBControlAsync(@cb);
  159.         if err = noErr then begin
  160.             while (cb.ioResult>=0) & (cb.open.localport=0) do begin
  161.                 ;
  162.             end;
  163.             local_port:=cb.open.localport;
  164.         end;
  165.         MTTCPPassiveOpen := err;
  166.     end;
  167.     
  168.     function MTTCPClose(var cb:TCPControlBlock; stream:StreamPtr):OSErr;
  169.     begin
  170.         MTZeroTCPCB(cb, stream, TCPcsClose);
  171.         MTTCPClose := PBControlAsync(@cb);
  172.     end;
  173.  
  174.     function MTTCPAbort(stream:StreamPtr):OSErr;
  175.         var
  176.             cb:TCPControlBlock;
  177.     begin
  178.         MTZeroTCPCB(cb, stream, TCPcsAbort);
  179.         MTTCPAbort := PBControlSync(@cb);
  180.     end;
  181.  
  182.     function MTMapState( state: longint): TCPStateType;
  183.     begin
  184.         case state of
  185.             0: 
  186.                 MTMapState := T_Dead;
  187.             2: 
  188.                 MTMapState := T_Bored;
  189.             4, 6: 
  190.                 MTMapState := T_Opening;
  191.             8: 
  192.                 MTMapState := T_Established;
  193.             10, 12, 16, 18, 20: 
  194.                 MTMapState := T_Closing;
  195.             14: 
  196.                 MTMapState := T_PleaseClose;
  197.             otherwise begin
  198.                 MTMapState := T_Unknown;
  199.             end;
  200.         end;
  201.     end;
  202.     
  203.     function MTTCPState(stream:StreamPtr):TCPStateType;
  204.         var
  205.             err:OSErr;
  206.             cb:TCPControlBlock;
  207.     begin
  208.         MTZeroTCPCB(cb, stream, TCPcsStatus);
  209.         err := PBControlSync(@cb);
  210.         if err = noErr then begin
  211.             MTTCPState := MTMapState( cb.status.connectionState );
  212.         end else begin
  213.             MTTCPState := T_Dead;
  214.         end;
  215.     end;
  216.     
  217.     procedure SanitizeHostName (var s: Str255);
  218.     begin
  219.         C2P(@s);
  220.         if s[Length(s)] = '.' then begin
  221.             s[0] := chr(Length(s) - 1);
  222.         end;
  223.     end;
  224.  
  225.     procedure DNRNameToAddrCompletion (hip: hostInfoPtr; drp: DNRRecordPtr);
  226.     begin
  227.         if hip^.rtnCode = cacheFaultErr then begin
  228.             hip^.rtnCode := noErr; { ARGGGGGHHHHHH }
  229.         end;
  230.         drp^.ioResult := hip^.rtnCode;
  231.         drp^.addr := drp^.hi.addrs[1];
  232.         if drp^.completion <> nil then begin
  233.             CallPascal04(drp, drp^.completion);
  234.         end;
  235.     end;
  236.  
  237.     procedure DNRNameToAddr (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
  238.         var
  239.             err: OSErr;
  240.     begin
  241.         drp^.ioResult := 1;
  242.         drp^.name := name;
  243.         drp^.completion := completion;
  244.         err := StrToAddr(name, drp^.hi, gDNRNameToAddrCompletionProc, Ptr(drp));
  245.         if err <> cacheFaultErr then begin
  246.             drp^.hi.rtnCode := err;
  247.             DNRNameToAddrCompletion(@drp^.hi, drp);
  248.         end;
  249.     end;
  250.  
  251.     procedure DNRNameToHInfo (name: Str255; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
  252.         var
  253.             err: OSErr;
  254.     begin
  255.         drp^.ioResult := 1;
  256.         drp^.name := name;
  257.         drp^.completion := completion;
  258.         err := HInfo(name, drp^.hi, gDNRNameToAddrCompletionProc, Ptr(drp));
  259.         if err <> cacheFaultErr then begin
  260.             drp^.hi.rtnCode := err;
  261.             DNRNameToAddrCompletion(@drp^.hi, drp);
  262.         end;
  263.     end;
  264.     
  265.     procedure DNRAddrToNameCompletion (hip: hostInfoPtr; drp: DNRRecordPtr);
  266.     begin
  267.         drp^.ioResult := hip^.rtnCode;
  268.         if drp^.ioResult = noErr then begin
  269.             BlockMoveData(@hip^.rtnHostName, @drp^.name, SizeOf(drp^.name));
  270.             SanitizeHostName(drp^.name);
  271.         end;
  272.         if drp^.completion <> nil then begin
  273.             CallPascal04(drp, drp^.completion);
  274.         end;
  275.     end;
  276.  
  277.     procedure DNRAddrToName (addr: longint; drp: DNRRecordPtr; completion: DNRCompletionProcPtr);
  278.         var
  279.             err: OSErr;
  280.     begin
  281.         drp^.ioResult := 1;
  282.         drp^.addr := addr;
  283.         drp^.completion := completion;
  284.         AddrToStr(addr, drp^.name);
  285.         err := AddrToName(addr, drp^.hi, gDNRAddrToNameCompletionProc, Ptr(drp));
  286.         if err <> cacheFaultErr then begin
  287.             drp^.hi.rtnCode := err;
  288.             DNRAddrToNameCompletion(@drp^.hi, drp);
  289.         end;
  290.     end;
  291.  
  292.     procedure UDPNotify (stream: StreamPtr; eventCode: integer; outstanding_count_ptr: LongIntPtr; ignored: Ptr);
  293.     begin
  294. {$unused(stream, ignored)}
  295.         if eventCode = UDPDataArrival then begin
  296.             if outstanding_count_ptr <> nil then begin
  297.                 Inc(outstanding_count_ptr^);
  298.             end;
  299.         end;
  300.     end;
  301.  
  302.     function MTUDPCreate(var stream:StreamPtr; var localport: ipPort; outstanding_count_ptr: LongIntPtr; buffer:Ptr; buffer_size:longint):OSErr;
  303.         var
  304.             err: OSErr;
  305.             cb: UDPControlBlock;
  306.     begin
  307.         MTZeroUDPCB(cb, nil, UDPcsCreate);
  308.         if outstanding_count_ptr <> nil then begin
  309.             outstanding_count_ptr^ := 0;
  310.         end;
  311.         cb.create.rcvBuff := buffer;
  312.         cb.create.rcvBuffLen := buffer_size;
  313.         cb.create.notifyProc := gUDPNotifyProc;
  314.         cb.create.userDataPtr := Ptr(outstanding_count_ptr);
  315.         cb.create.localport := localport;
  316.         err := PBControlSync(@cb);
  317.         if err = noErr then begin
  318.             localport := cb.create.localport;
  319.             stream := cb.udpStream;
  320.         end else begin
  321.             stream := nil;
  322.         end;
  323.         MTUDPCreate := err;
  324.     end;
  325.  
  326.     function MTUDPRelease (stream:StreamPtr): OSErr;
  327.         var
  328.             err: OSErr;
  329.             cb: UDPControlBlock;
  330.     begin
  331.         MTZeroUDPCB(cb, stream, UDPcsRelease);
  332.         err := PBControlSync(@cb);
  333.         MTUDPRelease := err;
  334.     end;
  335.  
  336.     function MTUDPRead (stream:StreamPtr; outstanding_count_ptr: LongIntPtr; var remoteip: longint; var remoteport: ipPort;
  337.                                     var datap: Ptr; var datalen: integer): OSErr;
  338.         var
  339.             err: OSErr;
  340.             cb: UDPControlBlock;
  341.     begin
  342.         MTZeroUDPCB(cb, stream, UDPcsRead);
  343.         err := PBControlSync(@cb);
  344.         if (err = noErr) & (outstanding_count_ptr <> nil) then begin
  345.             Dec(outstanding_count_ptr^);
  346.         end;
  347.         remoteip := cb.receive.remoteip;
  348.         remoteport := cb.receive.remoteport;
  349.         datap := cb.receive.rcvBuff;
  350.         datalen := cb.receive.rcvBuffLen;
  351.         MTUDPRead := err;
  352.     end;
  353.  
  354.     function MTUDPReturnBuffer (stream:StreamPtr; datap: Ptr): OSErr;
  355.         var
  356.             err: OSErr;
  357.             cb: UDPControlBlock;
  358.     begin
  359.         MTZeroUDPCB(cb, stream, UDPcsBfrReturn);
  360.         cb.return.rcvBuff := datap;
  361.         err := PBControlSync(@cb);
  362.         MTUDPReturnBuffer := err;
  363.     end;
  364.  
  365.     function MTUDPWrite (stream:StreamPtr; remoteip: longint; remoteport: ipPort;
  366.                                     datap: Ptr; datalen: integer; checksum: boolean): OSErr;
  367.         var
  368.             err: OSErr;
  369.             cb: UDPControlBlock;
  370.             wds: wdsType;
  371.     begin
  372.         MTZeroUDPCB(cb, stream, UDPcsWrite);
  373.         cb.send.remoteip := remoteip;
  374.         cb.send.remoteport := remoteport;
  375.         wds.size := datalen;
  376.         wds.buffer := datap;
  377.         wds.term := 0;
  378.         cb.send.wds := @wds;
  379.         cb.send.checksum := ord(checksum);
  380.         err := PBControlSync(@cb);
  381.         MTUDPWrite := err;
  382.     end;
  383.  
  384.     procedure IPZeroCB (var cb: IPControlBlock; call: integer);
  385.     { Zero out the control block parameters. }
  386.     begin
  387.         MZero(@cb, SizeOf(cb));
  388.         cb.ioCRefNum := mactcp_driver_refnum;
  389.         cb.csCode := call;
  390.     end;
  391.  
  392.     procedure IPCallCompletion (cbp: IPControlBlockPtr; userdata, extradata: Ptr; addr: UniversalProcPtr);
  393.     begin
  394.         CallPascal0444(cbp,userdata,extradata,addr);
  395.     end;
  396.  
  397.     procedure IPPingCompletionPascal (cbp: IPControlBlockPtr);
  398.         var
  399.             olda5: Ptr;
  400.             irp: PingRecordPtr;
  401.     begin
  402.         olda5 := SetPreservedA5;
  403.         Inc(ping_got_back);
  404.         irp := PingRecordPtr( cbp^.echoinfo.userDataPtr );
  405.         if (irp <> nil) & (irp^.completion <> nil) then begin
  406.             irp^.completion( cbp, irp );
  407.         end;
  408.         RestoreA5( olda5 );
  409.     end;
  410.  
  411. {$IFC GENERATINGPOWERPC}
  412.     procedure IPPingCompletion(cbp: IPControlBlockPtr);
  413.     begin
  414.         IPPingCompletionPascal(cbp);
  415.     end;
  416. {$ELSEC}
  417.  
  418. {$PUSH}
  419. {$ALIGN MAC68K}
  420.  
  421.     type
  422.         stackframe = packed record
  423.                 frameptr: Ptr;
  424.                 returnptr: Ptr;
  425.                 paramblockptr: Ptr;
  426.             end;
  427.         stackframeptr = ^stackframe;
  428.  
  429. {$ALIGN RESET}
  430. {$POP}
  431.  
  432.     function GetStackFrame: stackframeptr;
  433.     inline
  434.         $2E8E;
  435.  
  436.     procedure IPPingCompletion;
  437.     begin
  438.         IPPingCompletionPascal(IPControlBlockPtr(GetStackFrame^.paramblockptr));
  439.     end;
  440. {$ENDC}
  441.  
  442.     function MTIPSendPing (remotehost: ipAddr; timeout: integer; datap: Ptr; datalen: integer; completion: PingCompletionProc; irp: PingRecordPtr): OSErr;
  443.         var
  444.             cb: IPControlBlock;
  445.             oe: OSErr;
  446.     begin
  447.         if completion = nil then begin
  448.             Assert( irp = nil );
  449.             irp := nil;
  450.         end;
  451.         if irp <> nil then begin
  452.             irp^.completion := completion;
  453.         end;
  454.         IPZeroCB(cb, TCPcsEchoICMP);
  455.         cb.echo.dest := remotehost;
  456.         cb.echo.data.buffer := datap;
  457.         cb.echo.data.size := datalen;
  458.         cb.echo.timeout := timeout;
  459.         cb.echo.options := nil;
  460.         cb.echo.optlength := 0;
  461.         cb.echo.icmpCompletion := gIPPingCompletionProc;
  462.         cb.echo.userDataPtr := Ptr(irp);
  463.         oe := PBControlSync(@cb);
  464.         if oe = noErr then begin
  465.             Inc(ping_sent_out);
  466.         end;
  467.         MTIPSendPing := oe;
  468.     end;
  469.     
  470.     function InitTCPUtils(var msg: integer): OSStatus;
  471.     begin
  472. {$unused(msg)}
  473.         DidStartup( startup_check );
  474.         gDNRNameToAddrCompletionProc := NewProc(@DNRNameToAddrCompletion,uppPascal044ProcInfo);
  475.         gDNRAddrToNameCompletionProc := NewProc(@DNRAddrToNameCompletion,uppPascal044ProcInfo);
  476.         gUDPNotifyProc := NewProc(@UDPNotify,uppPascal04244ProcInfo);
  477.         gIPPingCompletionProc := NewProc(@IPPingCompletion, uppC04ProcInfo);
  478.         ping_sent_out := 0;
  479.         ping_got_back := 0;
  480.         InitTCPUtils := noErr;
  481.     end;
  482.  
  483.     procedure FinishTCPUtils;
  484.         var
  485.             dummy: boolean;
  486.             event: EventRecord;
  487.     begin
  488.         while ping_sent_out > ping_got_back do begin
  489.             dummy := WaitNextEvent( everyEvent, event, 0, nil );
  490.         end;
  491.     end;
  492.     
  493.     procedure StartupTCPUtils;
  494.     begin
  495.         SetStartup(InitTCPUtils, nil, 0, FinishTCPUtils);
  496.     end;
  497.     
  498. end.
  499.